home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Technotools
/
Technotools (Chestnut CD-ROM)(1993).ISO
/
lang_pas
/
mkscren2
/
mkscreen.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-10-15
|
8KB
|
251 lines
{$U+}{$V-}
type
str35 = string[35];
str80 = string[80];
const
label_end = ':';
field_mark = '_';
max_fields = 100;
used = '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$';
var
command_line : string[80] absolute Cseg:$80;
infile : text;
outfile : text;
final : text;
fname1 : string[255];
qtyfields : integer;
qtylabels : integer;
row,col : integer;
indata : string[255];
seqno : integer;
varname : array[1..max_fields] of string[35];
fieldW : array[1..max_fields] of integer;
checktype : array[1..max_fields] of char;
Lchoices : array[1..max_fields] of string[50];
maxlen : integer;
procedure capitalize(var str : str80);
var
index : integer;
begin
for index := 1 to length(str) do str[index] := upcase(str[index]);
end;
function tab(sname : str35;loc : integer) : str80;
var
wstr : str80;
index : integer;
begin
wstr := '';
for index := 1 to loc - length(sname) do wstr := ' ' + wstr;
tab := wstr;
end;
procedure make_final;
var puts : integer;
index : integer;
begin
assign(final,'SCREENxx.OVL');
rewrite(final);
writeln(final,'overlay procedure screenXX; {<<<}');
writeln(final,'const');
writeln(final,' total_fields = ',(seqno-1):2,';');
writeln(final,'label');
writeln(final,' repaint;');
writeln(final,'var');
writeln(final,' lun',tab('xxx',maxlen+1),': _textfile;');
writeln(final,' field_no',tab('xxxxxxxx',maxlen+1),': integer;');
writeln(final,' xf,yf',tab('xxxxx',maxlen+1),': array [1..total_fields] of integer;');
writeln(final,' done',tab('xxxx',maxlen+1),': boolean;');
for index := 1 to seqno-1 do
writeln(final,' ',varname[index],tab(varname[index],maxlen+1),': string[',fieldW[index]:2,'];');
writeln(final,'begin');
writeln(final,'cursor_on;');
writeln(final,'gotoxy(1,5);Clreos;');
writeln(final,'with header do begin {vvv}');
writeln(final,'if exist(work_drive+''@''+a.operation_no+''TXT.xxx'') then begin');
writeln(final,'assign(lun,work_drive+''@''+a.operation_no+''TXT.xxx'');');
writeln(final,'reset(lun);');
puts := 0;
for index := 1 to seqno-1 do begin
write(final,'readln(lun,',varname[index],');');
puts := succ(puts);
if (puts = 3) then begin writeln(final);puts := 0;end;
end;
writeln(final,'close(lun);');
writeln(final,'end else begin');
for index := 1 to seqno-1 do writeln(final,' ',varname[index],tab(varname[index],maxlen+1),':= '''';');
writeln(final,'end;');
writeln(final,'field_no := 1;');
writeln(final,'repaint:');
reset(outfile);
repeat readln(outfile,indata);writeln(final,indata);until eof(outfile);
writeln(final,'repeat');
writeln(final,'Case field_no of');
for index := 1 to seqno-1 do begin
writeln(final,index:2,' : begin');
writeln(final,' done := false;');
writeln(final,' repeat');
writeln(final,' get_field(',VarName[index],',',fieldW[index]:2,',xf[',index:2,
'],yf[',index:2,'],term,answer,0);');
write(final,' done := ');
case checktype[index] of
'I' : write(final,'integer');
'L' : write(final,'list');
'R' : write(final,'real');
'S' : write(final,'string');
end;
write(final,'_check(',varname[index],',');
case checktype[index] of
'I','R' : writeln(final,'''N'',''N'',''0'',',fieldW[index]:2,');');
'S' : writeln(final,'''Y'',''N'','' '',',fieldW[index]:2,');');
'L' : writeln(final,'''',Lchoices[index],''',''N'',''Y'',''N'','' '',',fieldW[index]:2,');');
end;
writeln(final,' until done;');
writeln(final,' end;');
end;
writeln(final,'end;');
writeln(final,'case answer of');
writeln(final,' ^I,^M,^X : if (field_no = total_fields) then field_no := 1 else field_no := field_no + 1;');
writeln(final,' ^E : if field_no = 1 then field_no := total_fields else field_no := field_no - 1;');
writeln(final,' ^T : field_no := 1;');
writeln(final,' ^B : field_no := total_fields;');
writeln(final,'end;');
writeln(final,'until (answer = ^M) and (field_no=1) or (answer = #27);');
writeln(final,'if (answer <> #27) then begin {vvv}');
writeln(final,'assign(lun,work_drive+''@''+a.operation_no+''TXT.xxx'');');
writeln(final,'rewrite(lun);');
puts := 0;
for index := 1 to seqno-1 do begin
write(final,'writeln(lun,',varname[index],');');
puts := succ(puts);
if (puts = 3) then begin writeln(final);puts := 0;end;
end;
writeln(final,'close(lun);');
writeln(final,'end;');
writeln(final,'end;');
writeln(final,'cursor_off;');
writeln(final,'end;');
close(final);
end;
procedure find_fields;
var
fstart,fend : integer;
lstart,lend : integer;
flabel : string[255];
nofield : boolean;
procedure get_varname;
begin
if (not nofield) then begin
textcolor(green);
gotoxy(1,10);clreol;write('Enter VARNAME for field label ''',flabel,''': ');
textcolor(yellow);
read(Varname[seqno]);
textcolor(green);
gotoxy(1,12);write('Field Check [I,L,R,S]: ');
repeat
read(KBD,checktype[seqno]);
checktype[seqno] := upcase(checktype[seqno]);
until checktype[seqno] in ['I','L','R','S'];
if (checktype[seqno] = 'L') then begin
textcolor(green);
gotoxy(1,14);write('Enter choices (i.e. ''Y,N,?''): ');
textcolor(yellow);
read(Lchoices[seqno]);
capitalize(Lchoices[seqno]);
gotoxy(1,14);clreol;
end else Lchoices[seqno] := '';
if (length(varname[seqno]) > maxlen) then maxlen := length(varname[seqno]);
fieldW[seqno] := (Fend - Fstart + 1);
end;
end;
procedure make_pascal;
begin
if (nofield) then begin
qtylabels := succ(qtylabels);
writeln(outfile,'gotoxy(',lstart:2,',',row:2,');','write(''',flabel,''');');
textcolor(black);textbackground(red);
gotoxy(5,6);write(qtylabels:3);
textcolor(yellow);textbackground(black);write(' Labels processed.');
end else begin
qtyfields := succ(qtyfields);
writeln(outfile,'draw_field(',lstart:2,',',row:2,',xf[',seqno:2,'],yf[',seqno:2,'],''',
flabel,''',',VarName[seqno],',0,',(fend-fstart+1):2,');');
textcolor(black);textbackground(red);
gotoxy(45,6);write(qtyfields:3);
textcolor(yellow);textbackground(black);write(' Fields processed.');
end;
end;
begin
col := 0;
while (col < length(indata)) do begin
col := succ(col);
if (indata[col] <> ' ') then begin
lstart := col;
lend := pos(label_end,indata);
if (lend = 0) then lend := length(indata);
flabel := copy(indata,lstart,lend-lstart+1);
fstart := pos(field_mark,indata);
if (fstart = 0) then nofield := true else nofield := false;
if (not nofield) then begin
fend := fstart;
repeat
fend := succ(fend)
until indata[fend] <> field_mark;
fend := pred(fend);
delete(indata,fstart,fend-fstart+1);
insert(copy(used,1,fend-fstart+1),indata,fstart);
end;
get_varname;
make_pascal;
if (not nofield) then seqno := succ(seqno);
indata[lend] := '$';
if (nofield) then col := length(indata) else col := fend;
end;
end;
end;
begin
textcolor(lightred);
clrscr;
writeln('Turbo Pascal Screen Code Manufacturing Program');
writeln('v01.01 Released 16 Oct 87 by R.P.Helmle');
if (length(command_line)> 0) then begin
delete(command_line,1,1);
fname1 := command_line;
assign(infile,fname1);
reset(infile);
assign(outfile,'SCREENXX.INC');
rewrite(outfile);
row := 0;
seqno := 1;
maxlen := 0;
qtyfields := 0;
qtylabels := 0;
repeat
readln(infile,indata);
row := succ(row);
if (row > 3) and (length(indata) > 1) then find_fields;
until eof(infile);
make_final;
close(outfile);
textcolor(lightgreen);
gotoxy(1,20);write('NOTE:');
gotoxy(1,21);write('Final screen source code saved in SCREENXX.OVL in current directory!');
gotoxy(1,22);write('Draw Field statements saved in SCREENXX.INC for fast location updates!');
end else begin
textcolor(red+blink);
writeln;writeln;
writeln('Error - You must specify the text file name in command line!');
writeln('Format: MkScreen <filename>');
end;
end.